home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / locals.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  3.6 KB  |  160 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * locals.c ---               The Optional Locals Word Set
  31.  * (duz 08Jul93)
  32.  */
  33.  
  34. #include <string.h>
  35.  
  36. #include "forth.h"
  37. #include "support.h"
  38. #include "compiler.h"
  39.  
  40. /* 1. Actions at runtime: */
  41.  
  42. code (locals_bar_execution)    /* establish local variables on return stack */
  43. {
  44.   Cell *p, *q;
  45.   Cell n;
  46.  
  47.   p = sp;
  48.   q = RP;
  49.   for (n = (Cell) *ip++; --n >= 0;)
  50.     *--q = *p++;
  51.   sp = p;
  52.   *--q = (Cell) lp;
  53.   *--q = (Cell) rp;
  54.   lp = q;
  55.   rp = (Xt **) q;
  56. }
  57.  
  58. code (locals_exit_execution)    /* alternative EXIT */
  59. {                /* cleans up local variable stack frame */
  60.   lp = (Cell *) rp[1];
  61.   rp = (Xt **) *rp;
  62.   ip = *rp++;
  63. }
  64.  
  65. code (local_execution)        /* retrieve current value of local variable */
  66. {
  67.   *--sp = lp[(Cell) *ip++];
  68. }
  69.  
  70. code (to_local_execution)    /* set current value of local variable */
  71. {
  72.   lp[(Cell) *ip++] = *sp++;
  73. }
  74.  
  75. /* 2. Actions at compile time */
  76.  
  77. int
  78. find_local (char *nm, int l)    /* returns index i to access local variable */
  79. {                /* relative to lp [i], 0 if not defined */
  80.   char name[32];
  81.   int i;
  82.  
  83.   store_c_string (nm, l, name, sizeof name);
  84.   if (LOWER_CASE)
  85.     upper (name, l);
  86.   for (i = 0; i < *sys.locals; i++)
  87.     if (strcmp (name, sys.local[i]) == 0)
  88.       return *sys.locals - i + 1;
  89.   return 0;
  90. }
  91.  
  92. int
  93. compile_local (char *name, int len)
  94. {
  95.   static pCode cfa = local_execution_;
  96.   int n;
  97.  
  98.   if ((n = find_local (name, len)) == 0)
  99.     return 0;
  100.   COMMA (&cfa);
  101.   COMMA (n);
  102.   return 1;
  103. }
  104.  
  105. static void
  106. paren_local (char *nm, int l)
  107. {
  108.   question_comp_ ();
  109.   if (l == 0)
  110.     return;
  111.   if (l > 31)
  112.     tHrow (THROW_NAME_TOO_LONG);
  113.   if (LOWER_CASE)
  114.     upper (nm, l);
  115.   if (sys.locals == NULL)
  116.     {
  117.       store_c_string (nm, l, sys.local[0], 32);
  118.       compile1 ();
  119.       sys.locals = (Cell *) DP;
  120.       COMMA (1);
  121.     }
  122.   else
  123.     {
  124.       if (find_local (nm, l))
  125.     tHrow (THROW_INVALID_NAME);
  126.       store_c_string (nm, l, sys.local[(*sys.locals)++], 32);
  127.     }
  128. }
  129.  
  130. Code (paren_local)
  131. {
  132.   paren_local ((char *) sp[1], sp[0]);
  133.   sp += 2;
  134. }
  135. COMPILES (paren_local, locals_bar_execution,
  136.       SKIPS_CELL, LOCALS_STYLE);
  137.  
  138. Code (locals_bar)
  139. {
  140.   for (;;)
  141.     {
  142.       char *p = word (' ');
  143.       int l = *(Byte *) p++;
  144.  
  145.       if (l == 1 && *p == '|')
  146.     break;
  147.       paren_local (p, l);
  148.     }
  149.   paren_local (NULL, 0);
  150. }
  151. COMPILES (locals_bar, locals_bar_execution,
  152.       SKIPS_CELL, LOCALS_STYLE);
  153.  
  154. LISTWORDS (locals) =
  155. {
  156.   CS ("(LOCAL)", paren_local),
  157.   CS ("LOCALS|", locals_bar)
  158. };
  159. COUNTWORDS (locals, "Locals + extensions");
  160.